BROCODE Summary Statistics

Final Project Summary Statistics

# Always print this out before your assignment
sessionInfo()
getwd()

library('tidyverse')

-- Attaching packages ---------------------------------------------------------------------------------------------------------------------- tidyverse 1.3.1 --
v ggplot2 3.3.5     v purrr   0.3.4
v tibble  3.1.5     v stringr 1.4.0
v tidyr   1.1.4     v forcats 0.5.1
v readr   2.0.2     
-- Conflicts ------------------------------------------------------------------------------------------------------------------------- tidyverse_conflicts() --
x readr::col_factor() masks scales::col_factor()
x purrr::discard()    masks scales::discard()
x dplyr::filter()     masks stats::filter()
x dplyr::lag()        masks stats::lag()

library("fs")
library('here')

here() starts at C:/Users/cabrooke/Documents/R/696/group project/final project/final_project

library('dplyr')
library('tidyverse')
library('ggplot2')
library('ggrepel')
library('ggthemes')
library('forcats')
library('rsample')
library('lubridate')

Attaching package: ‘lubridate’

The following objects are masked from ‘package:base’:

    date, intersect, setdiff, union

library('ggthemes')
library('kableExtra')

Attaching package: ‘kableExtra’

The following object is masked from ‘package:dplyr’:

    group_rows

library('pastecs')

Attaching package: ‘pastecs’

The following object is masked from ‘package:tidyr’:

    extract

The following objects are masked from ‘package:dplyr’:

    first, last

library('viridis')

Loading required package: viridisLite

Attaching package: ‘viridis’

The following object is masked from ‘package:scales’:

    viridis_pal

library('plotly')

Attaching package: ‘plotly’

The following object is masked from ‘package:ggplot2’:

    last_plot

The following object is masked from ‘package:stats’:

    filter

The following object is masked from ‘package:graphics’:

    layout

library('tidyquant')

Loading required package: PerformanceAnalytics
Loading required package: xts
Loading required package: zoo

Attaching package: ‘zoo’

The following objects are masked from ‘package:base’:

    as.Date, as.Date.numeric


Attaching package: ‘xts’

The following objects are masked from ‘package:pastecs’:

    first, last

The following objects are masked from ‘package:dplyr’:

    first, last


Attaching package: ‘PerformanceAnalytics’

The following object is masked from ‘package:graphics’:

    legend

Loading required package: quantmod
Loading required package: TTR
Registered S3 method overwritten by 'quantmod':
  method            from
  as.zoo.data.frame zoo 
== Need to Learn tidyquant? ===================================================================================================================================
Business Science offers a 1-hour course - Learning Lab #9: Performance Analysis & Portfolio Optimization with tidyquant!
</> Learn more at: https://university.business-science.io/p/learning-labs-pro </>

library('scales')

Final Project Cleaning and Summary Statistics

1a) Loading data

#Reading the data in and doing minor initial cleaning in the function call
#Reproducible data analysis should avoid all automatic string to factor conversions.
#strip.white removes white space 
#na.strings is a substitution so all that have "" will = na
data <- read.csv(here::here("final_project", "donor_data.csv"),
                 stringsAsFactors = FALSE,
                 strip.white = TRUE,
                 na.strings = "")

1b) Fixing the wonky DOB & Data cleanup

glimpse(data_cleaned$zipslry_range)

 logi [1:323000] NA NA NA NA NA NA ...

1c Creating factor variable for sex and married

data_cleaned <- 
  data_cleaned %>% 
  mutate(sex_fct = 
           fct_explicit_na(Sex)
  )


data_cleaned <-
data_cleaned %>% 
mutate(
  sex_simple = 
    fct_lump_n(Sex, n = 4)
)

#checking to see if its a factor
class(data_cleaned$sex_fct)

#checking levels
levels(data_cleaned$sex_simple)

#creating a table against Sex column 
table(data_cleaned$sex_fct, data_cleaned$sex_simple)

#making married a factor 
data_cleaned_columns <- 
  data_cleaned_columns %>% 
  mutate(married_fct = 
           fct_explicit_na(Married)
  )

#checking to see if its a factor
class(data_cleaned$married_fct)

1d #Mean, Median, and Count of Giving in Age Ranges

age_range_giving <- datacleaning %>%
  group_by(age_range) %>%
  summarise(avg_giving = mean(HH.Lifetime.Giving, na.rm = TRUE),
            med_giving = median(HH.Lifetime.Giving, na.rm = TRUE),
            amount_of_people_in_age_range = n())

Question 2

DonorSegment Analysis

#grouping by donorsegment and analyzing 
data_cleaned_columns %>%
  group_by(Donor.Segment) %>%
  summarise(Count = length(Donor.Segment),
            mean_total_giv = mean(HH.Lifetime.Giving)) %>%
  arrange(-Count) %>%
  filter(Count >= 100) %>%
  #added scales package to have the values show in dollar 
  mutate(mean_total_giv = dollar(mean_total_giv)) %>%
  kable(col.names = c("Donor Segment", "Count", "Mean HH Lifetime Giving"), align=rep('c', 3)) %>%
  kable_styling(bootstrap_options = c("striped", "hover"),
                full_width = F)

Donor Segment	Count	Mean HH Lifetime Giving
NA	232033	$0
Lost Donor	69733	$4,958
Lapsed Donor	11220	$11,195
Current Donor	5704	$104,142
Lapsing Donor	3879	$16,595
At-Risk Donor	657	$85,198

NA
NA

2a) Plotting average giving by age range

ggplot(age_range_giving, aes(avg_giving, age_range)) +
  geom_bar(stat = "identity")

NA
NA

2b) Count of donors based on age range (another way to look at it)

ggplot(datacleaning, 
       aes(age_range)) + 
       geom_bar() + 
       theme(axis.text.x = element_text(angle=45,
                                        hjust=1)) + 
  labs(title = "Count of Age Ranges", x = "", y = "")

NA
NA

2c) Boxplot of the Age Ranges Against the Lifetime Giving Amounts with a log scale applied - the reason we applied log scale is to resolve issues with visualizations that skew towards large values in our dataset.

ggplot(datacleaning, aes(age_range,HH.Lifetime.Giving,fill = age_range)) + 
  geom_boxplot(
  outlier.colour = "red") + 
  scale_y_log10() +
  theme(axis.text.x=element_text(angle=45,hjust=1))

Warning: Transformation introduced infinite values in continuous y-axis
Warning: Removed 232033 rows containing non-finite values (stat_boxplot).

NA
NA

2d) Splitting by age and gender

#creating boxplots 
datacleaning %>% 
  filter(Age < 100) %>% #removing the weird outliers that are over 100 
  filter(Sex %in% c("M", "F")) %>%
  ggplot(aes(Sex, Age)) + 
  geom_boxplot() + 
  theme_economist() + 
  ggtitle("Ages of Donors Based on Gender") + 
  xlab(NULL) + ylab(NULL)

NA
NA
NA
NA
NA

2e) Distribution of people in the states that they live.

  datacleaning %>%
  mutate(State = ifelse(State == " ", "NA", State)) %>%
  filter(State != "NA") %>%
  group_by(State) %>%
  summarise(Count = length(State)) %>%
  filter(Count > 800) %>%
  arrange(-Count) %>%
  kable(col.names = c("Donor's State", "Count")) %>%
  kable_styling(bootstrap_options = c("condensed"),
                full_width = F)

Donor's State	Count
CA	176695
WA	7958
TX	7268
NY	5661
CO	5073
AZ	4929
OR	4613
FL	4111
IL	3681
HI	3394
PA	2904
OH	2754
NV	2715
MI	2524
MA	2473
NJ	2311
VA	2158
NC	2087
GA	2045
MO	1889
MN	1732
MD	1488
TN	1443
IN	1417
CT	1380
WI	1330
UT	1174
OK	1151
AL	1120
LA	1110
ID	1096
SC	1076
KY	1032
KS	1027
NM	982
IA	880

NA
NA
NA
NA
NA
NA

2f) Looking at all donors first gift amount. 75% made a first gift of <100.

 no_non_donors <- datacleaning %>%
  filter(Lifetime.Giving != 0)
  
nd <- quantile(no_non_donors$HH.First.Gift.Amount, probs = c(.25,.50,.75,.9,.99), na.rm = TRUE)

nd <- as.data.frame(nd)

nd %>%
  kable(col.names = "Quantile") %>%
  kable_styling(bootstrap_options = c("striped", "hover"),
                full_width = F)

	Quantile
25%	3.8
50%	25.0
75%	100.0
90%	500.0
99%	15000.0

NA
NA
NA
NA

Modeling for you

3a) Linear model

#converting married Y and N to 1 and 0 
datacleaning <- datacleaning %>%
      mutate(Married_simple = ifelse(Married == "N",0,1))
 

mod1lm <- lm( Married_simple ~ Lifetime.Giving,
           data = datacleaning)

summary(mod1lm)

Call:
lm(formula = Married_simple ~ Lifetime.Giving, data = datacleaning)

Residuals:
    Min      1Q  Median      3Q     Max 
-0.4107 -0.2872 -0.2872  0.7128  0.7128 

Coefficients:
                      Estimate     Std. Error t value            Pr(>|t|)    
(Intercept)     0.287196453375 0.000796143577  360.73 <0.0000000000000002 ***
Lifetime.Giving 0.000000006818 0.000000007174    0.95               0.342    
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.4525 on 323224 degrees of freedom
Multiple R-squared:  2.795e-06, Adjusted R-squared:  -2.991e-07 
F-statistic: 0.9033 on 1 and 323224 DF,  p-value: 0.3419

Kmeans

is.numeric(data_cleaned$HH.Lifetime.Giving)

[1] TRUE

3a)

p <- datacleaning %>%
  ggplot(aes(Age)) + geom_histogram(bins=30, fill = "blue") + theme_economist_white() +
  ggtitle("Overall Donor Age Distribution") + 
  xlab(NULL) + ylab(NULL) + scale_x_continuous(breaks = seq(5,100,by = 20)) +
  scale_y_continuous(breaks = seq(20,100,by = 20)) + xlim(c(20,100))

Scale for 'x' is already present. Adding another scale for 'x', which will replace the existing scale.

ggplotly(p)

Warning: Removed 199288 rows containing non-finite values (stat_bin).

  
p

Warning: Removed 199288 rows containing non-finite values (stat_bin).
Warning: Removed 2 rows containing missing values (geom_bar).

ggplot(data = datacleaning, aes(x = Age)) + geom_histogram(fill ="blue")+ xlim(c(20,100))

`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Warning: Removed 199288 rows containing non-finite values (stat_bin).
Warning: Removed 2 rows containing missing values (geom_bar).

NA
NA
NA